perm filename PPSRT.F4[XX,LCS]2 blob
sn#182703 filedate 1975-10-20 generic text, type T, neo UTF8
00100 C SUBRS. SLUR, PLTSRT, (LINES, RDRAW)
00200
06300 SUBROUTINE SLUR
06382 IMPLICIT INTEGER(A-Q,T-Z)
06464 COMMON/SLR/ SLURX(72) /ALF/INP,SLURY(72)
06546 REAL CENTR
06628 COMMON /PLTR/PLT,RHT,RDIS
06710 COMMON R2,JA,CENTR,J2,R3,R4,R5,R6,R7,R8,R9,R10,RA,RB,
06792 1 K,KQ,TWICE,RST7,RX,RXX,RTILT,RC,RZ,RW,J3,J4,
06874 1 J5,J6,J7,J8,J9,J10,J11,JQ(8),R
06956 COMMON/PTR/PWDS(250),ITEM,L,I,IX /STF/RSTFAC(-3/4),RSTJ2
07120 CF DATA RZZ/2.8/
07202 C DEFAULT VALUE OF SLUR CURVE FACTOR IS 2.8
07284
07366 IF(JA.NE.12)GO TO 2
07380 CF RA=5.96*RSJT2*R5
07451 CF L=3
07522 CF J8=J8*RDIS
07593 CF IF(J7.LE.J6)J7=J7+360
07664 CF KQ=6
07735 CF IF(PLT)KQ=1
07806 CF10 DO 3 K=J6,J7,KQ
07877 CF R=K
07948 CF CALL LINES(R3+RA*SIND(R),CENTR+RA*COSD(R),L)
08019 CF3 L=2
08090 CF J8=J8-1
08161 CF IF(J8)RETURN
08232 CF RA=RA+1/RDIS
08303 CF L=3
08374 CF GO TO 10
08445 CJA=12 DRAWS CIRCLES. P5=RADIUS, P6=DEGR.1, P7=DEGR.2,P8=THICK(EXPANDS
08516 CALL CIRCLE
08678 RETURN
08760
08842 2 J10=1
08850 J4=-1
08924 KQ=6
09006 TWICE=-1
09088 C -1 FOR DISPLAY, USES ONLY 1/3 OF SEGMENTS
09170 IF(PLT.GE.0)GO TO 21
09252 TWICE=0
09334 KQ=1
09416 RWID=.2
09498 IF(RHT.LT.2)GO TO 21
09580 TWICE=1
09662 RWID=.14
09744 C IF SIZE IS GT.2 3 SLURS ARE DRAWN
09826 21 RST7=RSTJ2*7.
09900 RQQ=R5-R4
09908 IF(R6.GT.1000)CALL RNOTE(R6)
09990 GO TO (5,6,7),J8+4
10072 GO TO 4
10154 5 R=32
10236 C AFTER DOTTED NOTE
10318 GO TO 8
10400 6 R=22
10482 C BETWEEN NOTES
10564 8 RX=-1.3
10646 GO TO 9
10728 7 R=7
10810 RX=RSTJ2
10892 9 CALL RJBX(R)
10974 R6=R6+RX
11056 4 RXX=RHORZ(R6)-R3
11138 RTILT=RQQ*RST7
11220 80 RX=SQRT(RXX**2+RTILT**2)
11230 IF(J8.NE.-1)GO TO 1
11240 IF(RQQ.GT.8)RQQ=8
11250 IF(RQQ.LT.-8)RQQ=-8
11260 RQQ=RQQ*RSTFAC(J2)*1.0
11270 IF(R7)RQQ=-RQQ
11280 R3=R3-RQQ
11290 C MOVES STEEP SLUR LEFT OR RIGHT IF P8=-1
11302 1 R=CENTR
11384 IF(J8.GT.0)GO TO 180
11385 L=72
11466 C FOR BRACKETS
11508 CALL SLOOP
11550 CF RB=RX/71.
11641 CF DO 81 K=0,71
11732 CF81 SLURX(K+1)=RB*(K)+R3
11823 CF RA=R7*RST7
11914 CF41 IF(R9.EQ.0)R9=RZZ
12005 CF R=R+RA
12096 CF L=0
12187 CF DO 40 K=36,1,-1
12278 CF L=L+1
12369 CF RW=R-RA*(K/36.)**R9
12460 CF SLURY(L)=RW
12551 CF40 SLURY(73-L)=RW
12642 CF L=72
12733
12824 CF89 IF(RTILT.EQ.0)GO TO 87
12915 CF RW=ATAN2(RTILT,RXX)
13006 CF RA=SIN(RW)
13097 CF RB=COS(RW)
13188 CF RZ=SLURX(1)
13279 CF RW=SLURY(1)
13370 CF DO 83 K=1,L
13461 CF R=SLURX(K)-RZ
13552 CF RXX=SLURY(K)-RW
13643 CF SLURX(K)=RB*R-RA*RXX+RZ
13734 CF83 SLURY(K)=RB*RXX+RA*R+RW
13844
13926 87 IF(J4)CALL LINES(SLURX(J10),SLURY(J10),3)
13967 J5=KQ
13987 J6=J10
13997 J7=L
14000 IF(J4.NE.0)GO TO 22
14010 CALL EXCH(J6,J7)
14020 J5=-1
14080 22 DO 88 K=J6,J7,J5
14090 88 CALL LINES(SLURX(K),SLURY(K),2)
14336 IF(TWICE)RETURN
14450 TWICE=TWICE-1
14470 IF(J8.GT.0)GO TO 182
14490 J4=J4+1
14510 R7=R7+RWID
14530 C RWID=WIDTH OF SLUR -- SEE DATA
14550 GO TO 1
14570 180 RW=R+R7*RST7
14590 TWICE=-1
14610 KQ=1
14630 RX=RX+R3
14650 CC RA=(R5-R4)*RST7
14670 IF(J9.EQ.0)GO TO 181
14690 TWICE=2
14710 RZ=RTILT/(RX-R3)
14730 RXX=RX
14750 RWID=(R3+RXX)/2.
14770 182 IF(TWICE.EQ.1)GO TO 183
14790 C DOES LEFT SIDE FIRST.
14810 IF(TWICE.EQ.0)GO TO 184
14830 C LAST IS NUMBER.
14850 J8=2
14860 RC=RSTJ2*13.
14870 RX=RWID-RC
14890 RWW=RTILT
14910 185 RTILT=RZ*(RX-R3)
14930
14950 C PUT IN FUNC. HERE FOR THIS SLOPE AND FOR PART. BEAMS.
14970
14990 GO TO 181
15010 183 J8=3
15030 RX=RXX
15050 RTILT=RWW
15070 RXX=R3
15090 R3=RWID+RC
15110 RXX=RZ*(R3-RXX)
15130 R=R+RXX
15150 RW=RW+RXX
15170 GO TO 185
15190
15210 181 SLURX(1)=R3
15230 SLURY(1)=R
15250 SLURX(2)=R3
15270 SLURY(2)=RW
15290 SLURX(3)=RX
15310 SLURY(3)=RW+RTILT
15330 SLURX(4)=RX
15350 SLURY(4)=R+RTILT
15370 L=4
15390 IF(J8.EQ.2)L=3
15410 IF(J8.EQ.3)J10=2
15430 CC TWICE=-1
15450 GO TO 87
15470 184 J3=RWID
15490 C PUT IN VERT. POS. WHEN SLOPE!
15510 R4=RQQ/2.+R4+R7-1.
15530 R6=1.
15550 R7=1.
15560 R8=0
15570 CALL MAKNUM(R9)
15590 END
16300 C 8, POS1, STF, NT1, NT2, POS2, DIP(ABS. UNITS), P8
16400 C FOR P8: 0= SLUR, 1=BRACKETS, 2=LFT ONLY, 3=RT ONLY
16500
16600
17400 SUBROUTINE PLTSRT
17500 C SORTS DATA TO SHORTEN INVISIBLE VECTORS WHEN PLOTTING.
17600 CF IMPLICIT INTEGER(S-Z)
17700 COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
17800 DIMENSION P(250)
17810 CALL PSRT(P)
17820 END
17830
17900 CF DO 4 K=1,ITEM
18000 CF L=PWDS(K)
18050 CF LL=PWDS(K-1)
18060 CF LM=PWDS(K+1)
18100 CF A=RN(L+3)
18200 CF P(K)=A+1000*RN(L+2)
18210 CF IF(RN(L+1).NE.16)GO TO 40
18220 CF Y=PWDS(K-1)
18230 CF V=PWDS(K+1)
18240 CF IF(RN(Y+1).EQ.16)GO TO 41
18245 CF IF(RN(V+1).EQ.16)GO TO 41
18250 CF GO TO 4
18300 CF40 IF(A.GE.0)GO TO 4
18305 CF41 P(K)=-10000
18310 CF4 CONTINUE
18400 C PLOTS ALL NEG. POSITIONS FIRST.
18425 CF IX=I
18450 CF IF(I.LT.1500)I=1500
18500 CF Y=I
18537 CF I=I+IX-1
18556 CF IX=Y
18565 C IX IS M IN MAIN PROG.
18575 C LEAVES 1500 WDS IN RN FOR STORING "NOIR" DATA.
18600 CF2 A=P(1)
18700 CF L=1
18800 CF DO 1 K=1,ITEM
18900 CF IF(A.LE.P(K))GO TO 1
19000 CF A=P(K)
19100 CF L=K
19200 CF1 CONTINUE
19300 CF IF(A.EQ.10000.)RETURN
19400 C ALL ITEMS HAVE NOW BEEN SHUFFLED
19500 CF V=PWDS(L)
19600 CF P(L)=10000
19700 CF L=RN(V)+2+Y
19750 CF V=V-Y
19800 CC CALL LOOP(0,L,1,Y,V,RN)
19810 CF DO 3 K=Y,L
19820 CF3 RN(K)=RN(K+V)
19830 C REPLACED SUBROUTINE LOOP
19900 CF Y=L+1
20000 CF GO TO 2
20100 CF END
20200
20300
20400 CX SUBROUTINE LINES(A,B,L)
20500 CX COMMON /FL/IC,NZ,NX,RZ,XGP
20600 CX COMMON/DL/IIII,SAVER,AA /PLTR/IPLT,RHT,DIS
20700 CX COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20)
20800 CX COMMON/DPY/GO,TOP,BOT
20900 CX DATA BB/260.0/,CC/3.5/,DD/1.43/,MX/512/
21000 C SET XGP TO 1245.0 FOR MARGIN IN XEROX COPIES
21100 CX22 GO TO 23
21200 C CHANGE ABOVE TO 'J6CL' IN DDT TO USE NEXT ITEMS.
21300 CX24 AA=CC-DD*ABS(A)/BB
21400 C USE THIS IN DDT TO DISTORT ITEMS. CC MUST BE > DD
21500 CX B=B*AA
21600 CX23 IF(IPLT)GO TO 2
21900 CX IF(JA.EQ.44)RETURN
22000 CC K=B
22100 CC IF(K.GT.ITOP)ITOP=B
22200 CC IF(K.LT.IBOT)IBOT=B
22220 CX IF(B.GT.TOP)TOP=B
22240 CX IF(B.LT.BOT)BOT=B
22300 CX6 RETURN
22400 CC2 IF(IPLT.EQ.-2)RETURN
22500 C RXGP SETS UP-DOWN POS. ON XEROX PAPER (FRACTIONAL POSITIONS POSSIBLE.)
22600 CC IF(IXRX.EQ.0)GO TO 9
22700 CC M=ROFF(RXGP-B*RHT)
22800 CC N=ROFF(XGP+A*DIS)
22900 CC GO TO 8
23000 CX2 M=ROFF(A*DIS)
23100 CX N=ROFF(B*RHT)
23200 CX8 CALL PLOT(M,N,L)
23300 CX END